unit MouseEvent;

interface

uses
  Windows, Classes, Controls, ActiveX, ShlObj, Types, Messages,
  Models, WinShell;

function KeysToDropEffect(Keys: Integer): Integer;

type
  TMouseDownType = (mdtNone, mdtSingle, mdtDouble);
  TMouseEvent = class;

  TMouseAction = class (TInterfacedObject, IDropSource, IDropTarget)
  public
    constructor Create (aMainForm: IMainForm);
    function _AddRef: Integer; stdcall;
    function _Release: Integer; stdcall;
    {IDropSource}
    function QueryContinueDrag(fEscapePressed: BOOL; grfKeyState: Longint): HResult; stdcall;
    function GiveFeedback(dwEffect: Longint): HResult; stdcall;
    {IDropTarget}
    function DragEnter(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint;
                       var dwEffect: Longint): HResult; stdcall;
    function DragOver(grfKeyState: Longint; pt: TPoint;
                      var dwEffect: Longint): HResult; stdcall;
    function DragLeave: HResult; stdcall;
    function Drop(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint;
                  var dwEffect: Longint): HResult; stdcall;

  public
    FDnDEffect: Integer;
    FDnDObject: IDataObject;
    FDnDResult: HResult;
    {Drag Start}
    procedure DragStart;
    procedure DoDragOver (Keys: Integer; X, Y: Integer; var dwEffect: Integer);
    {Mouse Event}
    procedure DoDown (Msg: Cardinal; Keys: LongInt; X, Y: Integer);
    procedure DoDoubleClick (Msg: Cardinal; Keys: LongInt; X, Y: Integer);
    procedure DoUp (Msg: Cardinal; Keys: LongInt; X, Y: Integer);
    procedure DoTimer (N: Integer);
    procedure DoMove (X, Y: Integer);
  private
    MainForm: IMainForm;
    {Drag Drop}
    FDnDStart: Boolean;
    FDnDAccept: Boolean;
    FDnDKeys: Integer;
    {Mouse Event}
    LMouse: TMouseEvent;
    RMouse: TMouseEvent;
    MMouse: TMouseEvent;
    FDownPoint: TPoint;
  end;

  TMouseEvent = class
  public
    constructor Create (Action: TMouseAction; MouseKey: TMouseKey);
    {Mouse Event}
    procedure DoDown (MetaKey: TMetaKey; X, Y: Integer);
    procedure DoDoubleClick (MetaKey: TMetaKey; X, Y: Integer);
    procedure DoUp (MetaKey: TMetaKey; X, Y: Integer);
    procedure DoTimer;
    procedure DoLeave;
  private
    Action: TMouseAction;
    MouseKey: TMouseKey;
    {Mouse Down}
    FDownType: TMouseDownType;
    {Mouse Delayed}
    FDelayedType: TMouseDownType;
    FDelayedMetaKey: TMetaKey;
  end;

implementation

function KeysToDropEffect(Keys: Integer): Integer;
  begin
    if Keys and (MK_CONTROL or MK_SHIFT) = (MK_CONTROL or MK_SHIFT) then
      Result := DROPEFFECT_LINK
    else if Keys and MK_CONTROL <> 0 then
      Result := DROPEFFECT_COPY
    else
      Result := DROPEFFECT_MOVE;
  end;

(*
 * TMouseAction
 *)
constructor TMouseAction.Create (aMainForm: IMainForm);
  begin
    Inherited Create;
    MainForm := aMainForm;
    FDnDStart := False;
    FDnDAccept := False;
    FDnDObject := nil;
    FDnDEffect := DROPEFFECT_NONE;
    FDnDKeys := 0;
    with FDownPoint do begin
      X := -1;
      Y := -1;
    end;
    LMouse := TMouseEvent.Create(Self, mouseL);
    RMouse := TMouseEvent.Create(Self, mouseR);
    MMouse := TMouseEvent.Create(Self, mouseM);
  end;

(*
 * IInterface
 *)
function TMouseAction._AddRef: Integer; stdcall;
  begin
    Result := -1;
  end;
function TMouseAction._Release: Integer; stdcall;
  begin
    Result := -1;
  end;

(*
 * IDropSource
 *)
function TMouseAction.QueryContinueDrag(fEscapePressed: BOOL; grfKeyState: Longint): HResult; stdcall;
  begin
    if fEscapePressed then
      Result := DRAGDROP_S_CANCEL
    else if grfKeyState and (MK_LBUTTON or MK_RBUTTON or MK_MBUTTON) = 0 then
      Result := DRAGDROP_S_DROP
    else
      Result := S_OK
  end;

function TMouseAction.GiveFeedback(dwEffect: Longint): HResult; stdcall;
  begin
    Result := DRAGDROP_S_USEDEFAULTCURSORS
  end;

(*
 * IDropTarget
 *)
function TMouseAction.DragLeave: HResult; stdcall;
  begin
    FDnDAccept := False;
    FDnDEffect := DROPEFFECT_NONE;
    FDnDObject := nil;
    FDnDKeys := 0;
    Result := S_OK
  end;

function TMouseAction.DragEnter(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint;
                               var dwEffect: Longint): HResult; stdcall;
  begin
    FDnDAccept := dataObj.QueryGetData(HDropFormat) = S_OK;
    if FDnDAccept then begin
      FDnDEffect := DROPEFFECT_NONE;
      FDnDObject := nil;
      FDnDKeys := 0;
      DoDragOver(grfKeyState, pt.X, pt.Y, dwEffect);
    end else
      dwEffect := DROPEFFECT_NONE;

    Result := S_OK;
  end;

function TMouseAction.DragOver(grfKeyState: Longint; pt: TPoint;
                              var dwEffect: Longint): HResult; stdcall;
  begin
    if FDndAccept then begin
      DoDragOver(grfKeyState, pt.X, pt.Y, dwEffect);
    end else
      dwEffect := DROPEFFECT_NONE;

    Result := S_OK
  end;

function TMouseAction.Drop(const dataObj: IDataObject; grfKeyState: Longint; pt: TPoint;
                           var dwEffect: Longint): HResult; stdcall;
  var
    MouseKeys: TMouseKeys;
    MetaKey: TMetaKey;
    MouseKey: TMouseKey;
  begin
    if (FDnDAccept and not FDnDStart) and
       (FDnDEffect <> DROPEFFECT_NONE) then begin
      MouseKeys := Keys2MouseKeys(FDndKeys);
      MetaKey := Keys2MetaKey(grfKeyState);
      if mouseM in MouseKeys then
        MouseKey := mouseM
      else
      if mouseL in MouseKeys then
        if mouseR in MouseKeys then
          MouseKey := mouseM
        else
          MouseKey := mouseL
      else
      if mouseR in MouseKeys then
        MouseKey := mouseR
      else
        MouseKey := mouseNone;

      FDnDObject := dataObj;
      FDnDEffect := dwEffect;
      FDnDResult := S_OK;
      MainForm.DoMouseEvent(meDRAGDROP, MouseKey, MetaKey, pt.X, pt.Y);
      Result := FDnDResult;
      dwEffect := FDnDEffect;
    end else
    begin
      dwEffect := DROPEFFECT_NONE;
      Result := S_OK;
    end;

    {Reset DragDrop}
    FDnDAccept := False;
    FDnDStart := False;
    FDnDEffect := DROPEFFECT_NONE;
    FDnDObject := nil;
    FDnDKeys := 0;
  end;

(*
 * Drag Start
 *)
procedure TMouseAction.DragStart;
  var
    dwEffect: Integer;
    Res: HRESULT;
    Obj: IDataObject;
  begin
    with MainForm do
      Obj := GetDataObjectFromFiles(Handle, FileList.PathName, TargetFiles);
    if not Assigned(Obj) then Exit;

    FDnDStart := True;
    try
      LMouse.DoLeave;
      RMouse.DoLeave;
      MMouse.DoLeave;

      Writeln('start dragging');
      dwEffect := DROPEFFECT_COPY or DROPEFFECT_LINK or DROPEFFECT_MOVE;
      Res := DoDragDrop({IN}  Obj, Self, dwEffect,
                        {OUT} dwEffect);
      if Failed(Res) then begin
        Writeln('drag failed');
        Writeln(Res);
      end;
      Writeln('end dragging');
    finally
      FDndStart := False;
    end;
  end;

procedure TMouseAction.DoDragOver (Keys: Integer; X, Y: Integer; var dwEffect: Integer);
  var
    MouseKey: TMouseKey;
    MetaKey: TMetaKey;
    MouseKeys: TMouseKeys;
  begin
    if Keys = FDnDKeys then begin
      dwEffect := FDnDEffect;
      Exit;
    end;
    FDnDKeys := Keys;
    FDnDEffect := DROPEFFECT_NONE;

    MouseKeys := Keys2MouseKeys(Keys);
    MetaKey := Keys2MetaKey(Keys);

    if mouseM in MouseKeys then
      MouseKey := mouseM
    else
    if mouseL in MouseKeys then begin
      if mouseR in MouseKeys then
        MouseKey := mouseM
      else
        MouseKey := mouseL;
    end else
    if mouseR in MouseKeys then
      MouseKey := mouseR
    else
      MouseKey := mouseNone;

    MainForm.DoMouseEvent(meDRAGOVER, MouseKey, MetaKey, -1, -1);
    dwEffect := FDnDEffect;
  end;

(*
 * Mouse Event
 *)
procedure TMouseAction.DoDown (Msg: Cardinal; Keys: LongInt; X, Y: Integer);
  var
    MouseKey: TMouseKey;
    MetaKey: TMetaKey;
    MouseKeys: TMouseKeys;
    E: TMouseEvent;
  begin
    MouseKey := Msg2MouseKey(Msg);
    MetaKey := Keys2MetaKey(Keys);
    MouseKeys := Keys2MouseKeys(Keys);

    FDownPoint.X := X;
    FDownPoint.Y := Y;

    case MouseKey of
    mouseL:
      if mouseR in MouseKeys then begin
        RMouse.DoLeave;
        E := MMouse;
      end else
        E := LMouse;
    mouseR:
      if mouseL in MouseKeys then begin
        LMouse.DoLeave;
        E := MMouse;
      end else
        E := RMouse;
    mouseM:
      E := MMouse;
    else
      E := nil;
    end;

    E.DoDown(MetaKey, X, Y);
  end;

procedure TMouseAction.DoDoubleClick (Msg: Cardinal; Keys: LongInt; X, Y: Integer);
  var
    MouseKey: TMouseKey;
    MetaKey: TMetaKey;
    MouseKeys: TMouseKeys;
    E: TMouseEvent;
  begin
    MouseKey := Msg2MouseKey(Msg);
    MetaKey := Keys2MetaKey(Keys);
    MouseKeys:= Keys2MouseKeys(Keys);

    FDownPoint.X := X;
    FDownPoint.Y := Y;

    case MouseKey of
    mouseL:
      if mouseR in MouseKeys then begin
        RMouse.DoLeave;
        E := MMouse;
      end else
        E := LMouse;
    mouseR:
      if mouseL in MouseKeys then begin
        LMouse.DoLeave;
        E := MMouse
      end else
        E := RMouse;
    mouseM:
      E := MMouse;
    else
      E := nil;
    end;

    E.DoDoubleClick(MetaKey, X, Y);
  end;

procedure TMouseAction.DoUp (Msg: Cardinal; Keys: LongInt; X, Y: Integer);
  var
    MouseKey: TMouseKey;
    MetaKey: TMetaKey;
    MouseKeys: TMouseKeys;
    E: TMouseEvent;
  begin
    MouseKey := Msg2MouseKey(Msg);
    MetaKey := Keys2MetaKey(Keys);
    MouseKeys:= Keys2MouseKeys(Keys);

    FDownPoint.X := -1;
    FDownPoint.Y := -1;

    case MouseKey of
    mouseL:
      if mouseR in MouseKeys then
        E := MMouse
      else
        E := LMouse;
    mouseR:
      if mouseL in MouseKeys then
        E := MMouse
      else
        E := RMouse;
    mouseM:
      E := MMouse;
    else
      E := nil;
    end;

    E.DoUp(MetaKey, X, Y);        
  end;

procedure TMouseAction.DoTimer (N: Integer);
  var
    E: TMouseEvent;
  begin
    MainForm.EndMouseTimer(N);

    case TMouseKey(N) of
    mouseL: E := LMouse;
    mouseR: E := RMouse;
    mouseM: E := MMouse;
    else    E := nil;
    end;

    E.DoTimer;
  end;

procedure TMouseAction.DoMove (X, Y: Integer);
  var
    dX, dY: Integer;
  const
    CRITERIA = 100;
  begin
    if FDownPoint.X >= 0 then begin
      dX := X - FDownPoint.X;
      dY := Y - FDownPoint.Y;
      if dX*dX + dY*dY > CRITERIA then begin
        MainForm.DoMouseEvent(meDRAGSTART, mouseNone, 0, X, Y);
        FDownPoint.X := -1;
        FDownPoint.Y := -1;
      end;
    end;
  end;

(*
 * TMouseEvent
 *)
constructor TMouseEvent.Create (Action: TMouseAction; MouseKey: TMouseKey);
  begin
    inherited Create;
    Self.Action := Action;
    Self.MouseKey := MouseKey;
    FDownType := mdtNone;
    FDelayedType := mdtNone;
    FDelayedMetaKey := 0;
  end;

procedure TMouseEvent.DoDown (MetaKey: TMetaKey; X, Y: Integer);
  begin
    FDownType := mdtSingle;

    if FDelayedType <> mdtNone then begin
      FDelayedType := mdtNone;
      FDelayedMetaKey := 0;
      Action.MainForm.EndMouseTimer(Ord(MouseKey));
    end;

    FDelayedType := mdtSingle;
    FDelayedMetaKey := MetaKey;
    Action.MainForm.StartMouseTimer(Ord(MouseKey));

    Action.MainForm.DoMouseEvent(meSINGLEDOWN, MouseKey, MetaKey, X, Y);
  end;

procedure TMouseEvent.DoDoubleClick (MetaKey: TMetaKey; X, Y: Integer);
  begin
    FDownType := mdtDouble;

    if FDelayedType <> mdtNone then begin
      FDelayedType := mdtNone;
      FDelayedMetaKey := 0;
      Action.MainForm.EndMouseTimer(Ord(MouseKey));
    end;

    Action.MainForm.DoMouseEvent(meDOUBLEDOWN, MouseKey, MetaKey, X, Y);
  end;

procedure TMouseEvent.DoUp (MetaKey: TMetaKey; X, Y: Integer);
  begin
    case FDownType of
    mdtSingle: Action.MainForm.DoMouseEvent(meSINGLEUP, MouseKey, MetaKey, X, Y);
    mdtDouble: Action.MainForm.DoMouseEvent(meDOUBLEUP, MouseKey, MetaKey, X, Y);
    end;

    FDownType := mdtNone;
  end;

procedure TMouseEvent.DoTimer;
  begin
    if FDelayedType <> mdtNone then begin
      with Mouse.CursorPos do
        Action.MainForm.DoMouseEvent(meSINGLEDELAYED, MouseKey, FDelayedMetaKey, X, Y);

      FDelayedType := mdtNone;
      FDelayedMetaKey := 0;
    end;
  end;

procedure TMouseEvent.DoLeave;
  begin
    FDownType := mdtNone;
    FDelayedType := mdtNone;
    FDelayedMetaKey := 0;
  end;

end.
